home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / flic / flic-structs.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  2.1 KB  |  95 lines  |  [TEXT/CCL2]
  1. ;;; flic-structs.scm -- structures to define FLIC intermediate language
  2. ;;;
  3. ;;; author : Sandra Loosemore
  4. ;;; date   : 24 Mar 1992
  5.  
  6.  
  7.     
  8. (define-struct flic-exp
  9.   (type-template flic-td)
  10.   (slots
  11.    (unboxed?  (type bool) (default '#f) (bit #t))
  12.    (cheap?    (type bool) (default '#f) (bit #t))))
  13.  
  14.  
  15. ;;; Use a macro to define each subtype and a BOA constructor.
  16. ;;; Maybe eventually the constructors will need to do additional
  17. ;;; initialization and have to be defined by hand.
  18.  
  19. (define-local-syntax (define-flic name . slots)
  20.   (let* ((maker  (symbol-append 'make- name))
  21.      (pred   (symbol-append name '?))
  22.      (args   (map (function car) slots))
  23.      (inits  (map (lambda (x) (list x x)) args)))
  24.     `(begin
  25.        (define-struct ,name
  26.          (include flic-exp)
  27.      (predicate ,pred)
  28.      (slots ,@slots))
  29.        (define (,maker ,@args) (make ,name ,@inits))
  30.        ',name)))
  31.  
  32. (define-flic flic-lambda
  33.   (vars (type  (list var)))
  34.   (body (type flic-exp)))
  35.  
  36. (define-flic flic-let
  37.   ;; value exp is stored in var-value slot
  38.   (bindings (type (list var)))
  39.   (body (type flic-exp))
  40.   (recursive? (type bool) (bit #t)))
  41.  
  42. (define-flic flic-app
  43.   (fn (type flic-exp))
  44.   (args (type (list flic-exp)))
  45.   ;; true if number of args exactly matches arity of fn
  46.   (saturated? (type bool) (bit #t)))
  47.  
  48. (define-flic flic-ref
  49.   (var (type var)))
  50.  
  51. (define-flic flic-const
  52.   (value (type t)))
  53.  
  54. (define-flic flic-pack
  55.   (con (type con)))
  56.  
  57. (define-flic flic-case-block
  58.   (block-name (type symbol))
  59.   (exps       (type (list flic-exp))))
  60.  
  61. (define-flic flic-return-from
  62.   (block-name (type symbol))
  63.   (exp        (type flic-exp)))
  64.  
  65. (define-flic flic-and
  66.   (exps       (type (list flic-exp))))
  67.  
  68. (define-flic flic-if
  69.   (test-exp   (type flic-exp))
  70.   (then-exp   (type flic-exp))
  71.   (else-exp   (type flic-exp)))
  72.  
  73. (define-flic flic-sel
  74.   (con (type con))
  75.   (i (type int))
  76.   (exp (type flic-exp)))
  77.  
  78. (define-flic flic-is-constructor
  79.   (con (type con))
  80.   (exp (type flic-exp)))
  81.  
  82. (define-flic flic-con-number
  83.   (type (type algdata))
  84.   (exp (type flic-exp)))
  85.        
  86. (define-flic flic-void
  87.   )
  88.  
  89. (define-flic flic-update
  90.   (con (type con))
  91.   (slots (type (list (tuple int flic-exp))))
  92.   (exp (type flic-exp)))
  93.  
  94.  
  95.